home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl70b2.lha / tcl7.0b2 / library / init.tcl next >
Text File  |  1993-06-19  |  8KB  |  248 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # $Header: /user6/ouster/tcl/library/RCS/init.tcl,v 1.18 93/06/19 16:35:26 ouster Exp $ SPRITE (Berkeley)
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # All rights reserved.
  10. #
  11. # Permission is hereby granted, without written agreement and without
  12. # license or royalty fees, to use, copy, modify, and distribute this
  13. # software and its documentation for any purpose, provided that the
  14. # above copyright notice and the following two paragraphs appear in
  15. # all copies of this software.
  16. #
  17. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  18. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  19. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  20. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  21. #
  22. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  23. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  24. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  25. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  26. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  27. #
  28.  
  29. # unknown:
  30. # Invoked when a Tcl command is invoked that doesn't exist in the
  31. # interpreter:
  32. #
  33. #    1. See if the autoload facility can locate the command in a
  34. #       Tcl script file.  If so, load it and execute it.
  35. #    2. See if the command exists as an executable UNIX program.
  36. #       If so, "exec" the command.
  37. #    3. If the command was invoked at top-level:
  38. #        (a) see if the command requests csh-like history substitution
  39. #        in one of the common forms !!, !<number>, or ^old^new.  If
  40. #        so, emulate csh's history substitution.
  41. #        (b) see if the command is a unique abbreviation for another
  42. #        command.  If so, invoke the command.
  43.  
  44. proc unknown args {
  45.     global auto_noexec auto_noload env unknown_pending;
  46.  
  47.     set name [lindex $args 0]
  48.     if ![info exists auto_noload] {
  49.     #
  50.     # Make sure we're not trying to load the same proc twice.
  51.     #
  52.     if [info exists unknown_pending($name)] {
  53.         unset unknown_pending($name)
  54.         if {[array size unknown_pending] == 0} {
  55.         unset unknown_pending
  56.         }
  57.         error "self-referential recursion in \"unknown\" for command \"$name\"";
  58.     }
  59.     set unknown_pending($name) pending;
  60.     set ret [auto_load $name];
  61.     unset unknown_pending($name);
  62.     if ![array size unknown_pending] {
  63.         unset unknown_pending
  64.     }
  65.     if $ret {
  66.         return [uplevel $args]
  67.     }
  68.     }
  69.     if ![info exists auto_noexec] {
  70.     if [auto_execok $name] {
  71.         return [uplevel exec >&@stdout <@stdin $args]
  72.     }
  73.     }
  74.     if {([info level] == 1) && ([info script] == "")} {
  75.     if {$name == "!!"} {
  76.         return [uplevel {history redo}]
  77.     }
  78.     if [regexp {^!(.+)$} $name dummy event] {
  79.         return [uplevel [list history redo $event]]
  80.     }
  81.     if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  82.         puts "name is $name old is $old, new is $new"
  83.         return [uplevel [list history substitute $old $new]]
  84.     }
  85.     set cmds [info commands $name*]
  86.     if {[llength $cmds] == 1} {
  87.         return [uplevel [lreplace $args 0 0 $cmds]]
  88.     }
  89.     if {[llength $cmds] != 0} {
  90.         if {$name == ""} {
  91.         error "empty command name \"\""
  92.         } else {
  93.         error "ambiguous command name \"$name\": [lsort $cmds]"
  94.         }
  95.     }
  96.     }
  97.     error "invalid command name \"$name\""
  98. }
  99.  
  100. # auto_load:
  101. # Checks a collection of library directories to see if a procedure
  102. # is defined in one of them.  If so, it sources the appropriate
  103. # library file to create the procedure.  Returns 1 if it successfully
  104. # loaded the procedure, 0 otherwise.
  105.  
  106. proc auto_load cmd {
  107.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  108.  
  109.     if [info exists auto_index($cmd)] {
  110.     uplevel #0 $auto_index($cmd)
  111.     return 1
  112.     }
  113.     if [catch {set path $auto_path}] {
  114.     if [catch {set path $env(TCLLIBPATH)}] {
  115.         if [catch {set path [info library]}] {
  116.         return 0
  117.         }
  118.     }
  119.     }
  120.     if [info exists auto_oldpath] {
  121.     if {$auto_oldpath == $path} {
  122.         return 0
  123.     }
  124.     }
  125.     set auto_oldpath $path
  126.     catch {unset auto_index}
  127.     foreach dir $path {
  128.     set f ""
  129.     set error [catch {
  130.         set f [open $dir/tclIndex]
  131.         set id [gets $f]
  132.         if {$id == "# Tcl autoload index file, version 2.0"} {
  133.         eval [read $f]
  134.         } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
  135.         while {[gets $f line] >= 0} {
  136.             if {([string index $line 0] == "#")
  137.                 || ([llength $line] != 2)} {
  138.             continue
  139.             }
  140.             set name [lindex $line 0]
  141.             if {![info exists auto_index($name)]} {
  142.             set auto_index($name) "source $dir/[lindex $line 1]"
  143.             }
  144.         }
  145.         } else {
  146.         error "$dir/tclIndex isn't a proper Tcl index file"
  147.         }
  148.     } msg]
  149.     if {$f != ""} {
  150.         close $f
  151.     }
  152.     if $error {
  153.         error $msg $errorInfo $errorCode
  154.     }
  155.     }
  156.     if [info exists auto_index($cmd)] {
  157.     uplevel #0 $auto_index($cmd)
  158.     if {[info commands $cmd] != ""} {
  159.         return 1
  160.     }
  161.     }
  162.     return 0
  163. }
  164.  
  165. # auto_execok:
  166. # Returns 1 if there's an executable in the current path for the
  167. # given name, 0 otherwise.  Builds an associative array auto_execs
  168. # that caches information about previous checks, for speed.
  169.  
  170. proc auto_execok name {
  171.     global auto_execs env
  172.  
  173.     if [info exists auto_execs($name)] {
  174.     return $auto_execs($name)
  175.     }
  176.     set auto_execs($name) 0
  177.     foreach dir [split $env(PATH) :] {
  178.     if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  179.         set auto_execs($name) 1
  180.         return 1
  181.     }
  182.     }
  183.     return 0
  184. }
  185.  
  186. # auto_reset:
  187. # Destroy all cached information for auto-loading and auto-execution,
  188. # so that the information gets recomputed the next time it's needed.
  189. # Also delete any procedures that are listed in the auto-load index
  190. # except those related to auto-loading.
  191.  
  192. proc auto_reset {} {
  193.     global auto_execs auto_index auto_oldpath
  194.     foreach p [info procs] {
  195.     if {[info exists auto_index($p)] && ($p != "unknown")
  196.         && ![string match auto_* $p]} {
  197.         rename $p {}
  198.     }
  199.     }
  200.     catch {unset auto_execs}
  201.     catch {unset auto_index}
  202.     catch {unset auto_oldpath}
  203. }
  204.  
  205. # auto_mkindex:
  206. # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  207. # the name of the directory in which the tclIndex file is to be placed,
  208. # and a glob pattern to use in that directory to locate all of the relevant
  209. # files.
  210.  
  211. proc auto_mkindex {dir files} {
  212.     global errorCode errorInfo
  213.     set oldDir [pwd]
  214.     cd $dir
  215.     set dir [pwd]
  216.     append index "# Tcl autoload index file, version 2.0\n"
  217.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  218.     append index "# and sourced to set up indexing information for one or\n"
  219.     append index "# more commands.  Typically each line is a command that\n"
  220.     append index "# sets an element in the auto_index array, where the\n"
  221.     append index "# element name is the name of a command and the value is\n"
  222.     append index "# a script that loads the command.\n\n"
  223.     foreach file [glob $files] {
  224.     set f ""
  225.     set error [catch {
  226.         set f [open $file]
  227.         while {[gets $f line] >= 0} {
  228.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  229.             append index "set [list auto_index($procName)]"
  230.             append index " \"source \$dir/$file\"\n"
  231.         }
  232.         }
  233.         close $f
  234.     } msg]
  235.     if $error {
  236.         set code $errorCode
  237.         set info $errorInfo
  238.         catch [close $f]
  239.         cd $oldDir
  240.         error $msg $info $code
  241.     }
  242.     }
  243.     set f [open tclIndex w]
  244.     puts $f $index nonewline
  245.     close $f
  246.     cd $oldDir
  247. }
  248.